{-# OPTIONS_GHC -XRecordWildCards -XNamedFieldPuns -fglasgow-exts #-}
module Types where

import Text.XML.Light.Types()
import qualified Data.Map as Map
import Data.List (nubBy, (\\))
import Data.Char
import Control.Arrow


data WsType   = WsComplexType {
                    wsctPrefix      :: String,
                    wsctName		:: String,
                    wsctAlias		:: String,
                    wsctElems		:: [WsElem]
                } 
              | WsSimpleType String 
                deriving (Show, Eq, Ord, Read)

isCT :: WsType -> Bool
isCT (WsComplexType {}) = True
isCT _ = False

data WsElem   = WsElem {                
          wselName 			:: String,
          wselType 			:: WsType,
          wselMinOccurs		:: MinOcc,
          wselMaxOccurs		:: MaxOcc,
          wselNillable 		:: Bool,
          wselAlias			:: String
        } deriving (Show, Eq, Ord, Read)
                
data MinOcc   = Zero | MinOne	deriving (Show, Eq, Ord, Read)
data MaxOcc   = MaxOne | Unbounded deriving (Show, Eq, Ord, Read)

data WsDescr  = WsDescr {
            wsdName         :: String,
            wsdNamespaces   :: [(String, String)],
            wsdSchemas      :: [WsSchema],
            wsdOpers        :: [WsOper]
        } deriving (Show, Eq, Ord)
                
data WsSchema = WsSchema {
            wssNamespaces   :: [(String, String)],
            wssTypes        :: [WsType]
        } deriving (Show, Eq, Ord)
                
data WsOper   = WsOper {
          wsopName 			:: String,
          wsopInput			:: WsType,
          wsopOutput 		:: WsType
        } deriving (Show, Eq, Ord)
                
wsdl :: String
wsdl = "wsdl"
wsdlURI :: String
wsdlURI = "http://schemas.xmlsoap.org/wsdl/"
xmlns :: String
xmlns = "xmlns"
xs :: String
xs = "xs"
xsURI :: String
xsURI = "http://www.w3.org/2001/XMLSchema"

getPrefName :: String -> (String, String)
getPrefName n 
    | ':' `elem` n = break (==':') >>> second (dropWhile (`elem` ":/")) $ n
    | otherwise = ("", n)
    
upperFirst :: String -> String
upperFirst (s:ss) = toUpper s : ss
upperFirst _ = ""

lowerFirst :: String -> String
lowerFirst (s:ss) = toLower s : ss
lowerFirst _ = ""
    

type TypeNamesMap = Map.Map String (String, String, Map.Map String String) -- typeName newTypeName, fieldPrefix, Map fieldName newFieldName

setAliases :: WsDescr -> [(String, String, String, [(String, String)])] -> WsDescr
setAliases wsd ml = 
    wsd { wsdOpers = [ op { wsopInput = f (wsopInput op), wsopOutput = f (wsopOutput op)} | op <- wsdOpers wsd ]	}
    where
        m = Map.fromList . map (\(old, new, pref, fs) -> (old, (new, pref, Map.fromList fs))) $ ml
        f = setAliasesTp m 

setAliasesTp :: Map.Map String (String, String, Map.Map k a) -> WsType -> WsType
setAliasesTp m ct@(WsComplexType {wsctName}) = ct { wsctAlias = a } 
    where
        (a, _, _) = Map.findWithDefault (defName wsctName, defPref, Map.empty) wsctName m
        defPref = map toLower $ filter isUpper wsctName
setAliasesTp _ st = st

defName :: String -> String
defName name = if 3 > (length . take 3 $ dn) then name else dn
    where
        dn = defName' (2::Integer) name
        defName' _ "" = ""
        defName' 0 cur_name = '_':cur_name
        defName' k (n:cur_name) = 
            (n:) . defName' (k-1) $ dropWhile (not . isUpper) cur_name
            

getAliases :: WsDescr -> [(String, String, String, [(String, String)])]
getAliases wsd = nubBy (\(a,_,_,_) (b,_,_,_) -> a == b) $ concat [getAliasesTp t | 
        op <- wsdOpers wsd,
        t <- map (flip ($) op) [wsopInput, wsopOutput]
    ]
    
getAliasesTp :: WsType -> [(String, String, String, [(String, String)])]
getAliasesTp (WsComplexType {wsctName, wsctAlias, wsctElems}) = 
    (wsctName, wsctAlias, p, map (\e' ->(wselName e', wselAlias e' \\ p)) wsctElems) :
                    concat [getAliasesTp $ wselType e | e <- wsctElems]
    where 
        p = getPrefix "" $ map wselAlias wsctElems
        getPrefix _ [] = ""
        getPrefix _ [_] = ""
        getPrefix p' ("":_) = reverse p'
        getPrefix p' ((c':cs'):es') = if all (\e'->[c'] == take 1 e') es' then getPrefix (c':p') $ cs' : map tail es' else reverse p'

getAliasesTp _ = []
